home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / packages / blink-paren.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  6.4 KB  |  181 lines
  1. ;;; blink-paren.el --- blink the matching paren, just like Zmacs
  2. ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
  3.  
  4. ;; Author: devin@lucid.com.
  5. ;; Keywords: faces
  6.  
  7. ;; This file is part of XEmacs.
  8.  
  9. ;; XEmacs is free software; you can redistribute it and/or modify it
  10. ;; under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; XEmacs is distributed in the hope that it will be useful, but
  15. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. ;; General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  21. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22.  
  23. ;;; Synched up with: Not in FSF.
  24.  
  25. (defvar blink-paren-timeout 0.2
  26.   "*If the cursor is on a parenthesis, the matching parenthesis will blink.
  27. This variable controls how long each phase of the blink lasts in seconds.
  28. This should be a fractional part of a second (a float.)")
  29.  
  30. (defvar highlight-paren-expression nil
  31.   "*If true, highlight the whole expression of the paren under the cursor
  32. instead of blinking (or highlighting) the matching paren.  This will highlight
  33. the expression using the `highlight-expression' face.")
  34.  
  35. ;;; The blinking paren alternates between the faces blink-paren-on and
  36. ;;; blink-paren-off.  The default is for -on to look just like default
  37. ;;; text, and -off to be invisible.  You can change this so that, for
  38. ;;; example, the blinking paren fluctuates between bold and italic...
  39. ;;;
  40. ;;; You can make the matching paren merely be highlighted (and not blink)
  41. ;;; by setting the blink-paren-on and blink-paren-off faces to have the same
  42. ;;; attributes; if you do this, then emacs will not consume as much CPU.
  43. ;;;
  44. ;;; If highlight-paren-expression is true, then the whole sexp between the
  45. ;;; parens will be displayed in the `highlight-expression' face instead.
  46.  
  47. (make-face 'blink-paren-on)
  48. (make-face 'blink-paren-off)
  49. (make-face 'highlight-expression)
  50.  
  51. ;; extent used to change the face of the matching paren
  52. (defvar blink-paren-extent nil)
  53.  
  54. ;; timeout to blink the face
  55. (defvar blink-paren-timeout-id nil)
  56.  
  57. ;; find if we should look foward or backward to find the matching paren
  58. (defun blink-paren-sexp-dir ()
  59.   (cond ((and (< (point) (point-max))
  60.           (eq (char-syntax (char-after (point))) ?\())
  61.      1)
  62.     ((and (> (point) (point-min))
  63.           (eq (char-syntax (char-after (- (point) 1))) ?\)))
  64.      -1)
  65.     (t ())))
  66.  
  67. ;; make an extent on the matching paren if any.  return it.
  68. (defun blink-paren-make-extent ()
  69.   (let ((dir (blink-paren-sexp-dir)))
  70.     (and dir
  71.      (condition-case ()
  72.          (let* ((parse-sexp-ignore-comments t)
  73.             (other-pos (let ((pmin (point-min))
  74.                      (pmax (point-max))
  75.                      (point (point)))
  76.                  (unwind-protect
  77.                      (progn
  78.                        (narrow-to-region
  79.                     (max pmin (- point blink-matching-paren-distance))
  80.                     (min pmax (+ point blink-matching-paren-distance)))
  81.                        (forward-sexp dir) (point))
  82.                    (narrow-to-region pmin pmax)
  83.                    (goto-char point))))
  84.             (extent (if (= dir 1)
  85.                 (make-extent (if highlight-paren-expression
  86.                          (point)
  87.                            (- other-pos 1))
  88.                          other-pos)
  89.                   (make-extent other-pos
  90.                        (if highlight-paren-expression
  91.                            (point)
  92.                          (+ other-pos 1))))))
  93.            (set-extent-face extent (if highlight-paren-expression
  94.                        'highlight-expression
  95.                      'blink-paren-on))
  96.            extent)
  97.        (error nil)))))
  98.  
  99. ;; callback for the timeout
  100. ;; swap the face of the extent on the matching paren
  101. (defun blink-paren-timeout (arg)
  102.   ;; The extent could have been deleted for some reason and not point to a
  103.   ;; buffer anymore.  So catch any error to remove the timeout.
  104.   (condition-case ()
  105.       (set-extent-face blink-paren-extent 
  106.                (if (eq (extent-face blink-paren-extent)
  107.                    'blink-paren-on)
  108.                'blink-paren-off
  109.              'blink-paren-on))
  110.     (error (blink-paren-pre-command))))
  111.  
  112. ;; called after each command is executed in the post-command-hook
  113. ;; add the extent and the time-out if we are on a paren.
  114. (defun blink-paren-post-command ()
  115.   (blink-paren-pre-command)
  116.   (if (and (setq blink-paren-extent (blink-paren-make-extent))
  117.        (not highlight-paren-expression)
  118.        (not (and (face-equal 'blink-paren-on 'blink-paren-off)
  119.              (progn
  120.                (set-extent-face blink-paren-extent 'blink-paren-on)
  121.                t)))
  122.        (or (floatp blink-paren-timeout)
  123.            (integerp blink-paren-timeout)))
  124.       (setq blink-paren-timeout-id
  125.         (add-timeout blink-paren-timeout 'blink-paren-timeout ()
  126.              blink-paren-timeout))))
  127.  
  128. ;; called before a new command is executed in the pre-command-hook
  129. ;; cleanup by removing the extent and the time-out
  130. (defun blink-paren-pre-command ()
  131.   (condition-case c  ; don't ever signal an error in pre-command-hook!
  132.       (let ((inhibit-quit t))
  133.     (if blink-paren-timeout-id
  134.         (disable-timeout (prog1 blink-paren-timeout-id
  135.                    (setq blink-paren-timeout-id nil))))
  136.     (if blink-paren-extent
  137.         (delete-extent (prog1 blink-paren-extent
  138.                  (setq blink-paren-extent nil)))))
  139.     (error
  140.      (message "blink paren error! %s" c))))
  141.  
  142.  
  143. (defun blink-paren (&optional arg)
  144.   "Toggles paren blinking on and off.
  145. With a positive argument, turns it on.
  146. With a non-positive argument, turns it off."
  147.   (interactive "P")
  148.   (let* ((was-on (not (not (memq 'blink-paren-pre-command pre-command-hook))))
  149.      (on-p (if (null arg)
  150.            (not was-on)
  151.         (> (prefix-numeric-value arg) 0))))
  152.     (cond (on-p
  153.  
  154.        ;; in case blink paren was dumped, this needs to be setup
  155.        (or (face-differs-from-default-p 'blink-paren-off)
  156.            (progn
  157.          (set-face-background 'blink-paren-off (face-background 'default))
  158.          (set-face-foreground 'blink-paren-off (face-background 'default))))
  159.  
  160.        (or (face-differs-from-default-p 'highlight-expression)
  161.            (set-face-underline-p 'highlight-expression t))
  162.        
  163.        (add-hook 'pre-command-hook 'blink-paren-pre-command)
  164.        (add-hook 'post-command-hook 'blink-paren-post-command)
  165.        (setq blink-matching-paren nil))
  166.       (t
  167.        (remove-hook 'pre-command-hook 'blink-paren-pre-command)
  168.        (remove-hook 'post-command-hook 'blink-paren-post-command)
  169.        (and blink-paren-extent (detach-extent blink-paren-extent))
  170.        (setq blink-matching-paren t)))
  171.     on-p))
  172.  
  173. (defun blink-paren-init ()
  174.   "obsolete - use `blink-paren' instead."
  175.   (interactive)
  176.   (blink-paren 1))
  177.  
  178. (provide 'blink-paren)
  179.  
  180. (blink-paren 1)
  181.